home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
lisp
/
eulisp
/
feel-075.lha
/
feel0.75
/
Src
/
read.c
< prev
next >
Wrap
C/C++ Source or Header
|
1992-06-18
|
17KB
|
680 lines
/* ******************************************************************** */
/* read.c Copyright (C) Codemist and University of Bath 1989 */
/* */
/* Input functions */
/* ******************************************************************** */
/*
* Change Log:
* Version 1, April 1989
* Version 2, May 1989
* Changed whole system to add stream argument everywhere
* Made curchar part of the stream structure, and consequent changes
* include removal of re-initialise-io
*/
#include <stdio.h>
#include <string.h>
#include <ctype.h>
#ifndef DONT_HAVE_STDLIB_H
#include <stdlib.h>
#endif
#include "funcalls.h"
#include "defs.h"
#include "structs.h"
#include "error.h"
#include "global.h"
#include "garbage.h"
#include "symboot.h"
extern FILE *yyin;
static int boffop;
static char boffo[255];
LispObject q_eof, q_rpar, q_period, q_lpar, q_quotemark,
q_backquotemark, q_comma, q_at;
LispObject sym_quote;
int ttype;
#define NO_CHARACTER 0x1000000
LispObject readnumber(LispObject*,int);
LispObject readinteger(LispObject*,int);
LispObject readidentifier(LispObject*,int);
LispObject readstring(LispObject*);
LispObject readatom(LispObject*);
LispObject read1(LispObject*);
LispObject Fn_endofstreamcharp(LispObject*);
LispObject Fn_endoflinecharp(LispObject*);
LispObject Fn_read_ln(LispObject*);
LispObject Fn_readchar(LispObject*);
LispObject Fn_readbyte(LispObject*);
LispObject Fn_peekchar(LispObject*);
LispObject Fn_peekbyte(LispObject*);
LispObject lookupname(LispObject*, int);
LispObject ascii(LispObject*,int);
LispObject numob(LispObject*,int);
LispObject floatob(LispObject*,int);
LispObject sym_quasiquote;
LispObject sym_unquote;
LispObject sym_unquote_splicing;
LispObject current_input;
void initialise_input(LispObject *stacktop)
{
LispObject fun;
#ifdef WITH_FUDGE
{
void initialise_fudge(void);
initialise_fudge();
}
#endif
q_eof = allocate_char(stacktop,(char) EOF);
add_root(&q_eof);
q_lpar = allocate_char(stacktop,'(');
add_root(&q_lpar);
q_rpar = allocate_char(stacktop,')');
add_root(&q_rpar);
q_period = allocate_char(stacktop,'.');
add_root(&q_period);
q_quotemark = allocate_char(stacktop,'\'');
add_root(&q_quotemark);
q_backquotemark = allocate_char(stacktop,'`');
add_root(&q_backquotemark);
q_comma = allocate_char(stacktop,',');
add_root(&q_comma);
q_at = allocate_char(stacktop,'@');
add_root(&q_at);
sym_quasiquote = (LispObject) get_symbol(stacktop,"quasiquote");
add_root(&sym_quasiquote);
sym_unquote = (LispObject) get_symbol(stacktop,"unquote");
add_root(&sym_unquote);
sym_unquote_splicing = (LispObject) get_symbol(stacktop,"unquote-splicing");
add_root(&sym_unquote_splicing);
make_module_function(stacktop,"read",Fn_read,1);
(void) make_module_function(stacktop,"end-of-line-p",Fn_endoflinecharp,1);
fun = make_module_function(stacktop,"read-char",Fn_readchar,1);
fun = make_module_function(stacktop,"read-byte",Fn_readbyte,1);
fun = make_module_function(stacktop,"peek-char",Fn_peekchar,1);
fun = make_module_function(stacktop,"peek-byte",Fn_peekbyte,1);
fun = make_module_function(stacktop,"read-with-line-numbers",Fn_read_ln,1);
IGNORE(fun);
}
static LispObject read0(LispObject *stacktop)
{
LispObject k = readatom(stacktop); /* First token in list */
if (ttype==3) {
if (k==q_lpar) return read1(stacktop);
if (k==q_quotemark) {
ttype = 5; /* A list */
k = read0(stacktop); /* Thing to be QUOTEd */
EUCALLSET_2(k, Fn_cons, k, nil);
return EUCALL_2(Fn_cons, sym_quote, k);
}
else if (k==q_backquotemark) {
ttype = 5; /* A list */
k = read0(stacktop); /* Thing to be QUOTEd */
EUCALLSET_2(k, Fn_cons, k, nil);
return EUCALL_2(Fn_cons, sym_quasiquote, k);
}
else if (k==q_comma) {
EUCALLSET_1(k, Fn_peekchar, current_input); /* Are we splicing ? */
if (k->CHAR.code=='@') {
EUCALL_1(Fn_readchar, current_input);
ttype = 5;
k = read0(stacktop);
EUCALLSET_2(k, Fn_cons, k,nil);
return EUCALL_2(Fn_cons, sym_unquote_splicing,k);
}
ttype = 5; /* A list */
k = read0(stacktop); /* Thing to be QUOTEd */
EUCALLSET_2(k, Fn_cons, k,nil);
return EUCALL_2(Fn_cons, sym_unquote, k);
}
else return k; /* ttype=3 -> just pass it back */
}
ttype = 5;
return k; /* entire list is atomic */
}
#define packchar(ch) boffo[boffop++] = ch
LispObject read1(LispObject *stacktop)
{
LispObject l=read0(stacktop);
LispObject k=nil;
if (ttype==3)
if (l==q_rpar || l==q_eof) return nil;
EUCALLSET_2(k, Fn_cons, nil, nil);
CAR(k) = l;
l = k;
while (TRUE) {
LispObject m=read0(stacktop);
if (ttype==3) {
if (m==q_period) {
CDR(l) = read0(stacktop);
m = read0(stacktop);
if ((ttype!=3) || m!=q_rpar)
(void) CallError(stacktop,
"Trouble reading dot notation",nil,NONCONTINUABLE);
ttype = 5;
return k;
}
else if (m==q_rpar || m==q_eof) {
ttype = 5; return k;
}
}
EUCALLSET_2(m, Fn_cons, m, nil); /* Saved in cons */
CDR(l) = m;
l = m;
}
return(nil);
}
int nextchar()
{
if ((current_input->STREAM).curchar==0) {
(current_input->STREAM).curchar = getc((current_input->STREAM).handle);
if ((current_input->STREAM).curchar==EOF) goto seteof;
}
{
int k = ((current_input->STREAM).curchar)&0xff;
if (k!=0xff)
(current_input->STREAM).curchar = ((current_input->STREAM).curchar)>>8;
return k;
}
seteof:
(current_input->STREAM).curchar = 0xff; /* END OF FILE MARKER */
return 0xff;
}
/* pushchar(,k) arranges that when nextchar is next called */
/* it will return the value k, but after re-reading k */
/* it will revert to normal operation. up to three pushed */
/* characters can be pending. various special values are */
/* pushed to allow for for complicated actions. pushchar(,eof) */
/* has no effect. */
void pushchar(LispObject *stacktop, int k)
{
if (k==0xff) {
if ((((current_input->STREAM).curchar)&0xff0000)!=0)
(void) CallError(NULL,"pushchar overflow on code ~d",
allocate_integer(stacktop,k),NONCONTINUABLE);
return;
}
(current_input->STREAM).curchar = (((current_input->STREAM).curchar)<<8)+k;
return;
}
LispObject read_long_name(LispObject *stacktop, int initial, char *name)
{
int k = nextchar();
int i;
if (k != name[1] && k != toupper(name[1])) { /* it was a simple #\s etc */
pushchar(stacktop,k);
return allocate_char(stacktop, initial);
}
for (i = 2; i < strlen(name); i++) {
k = nextchar();
if (k != name[i] && k != toupper(name[i]))
return CallError(stacktop, "bad character escape",
allocate_string(stacktop, name, strlen(name)),
CONTINUABLE);
}
switch (name[0]) {
case 's': return allocate_char(stacktop, ' ');
case 'n': return allocate_char(stacktop,'\n');
case 'r': return allocate_char(stacktop,'\r');
case 't': return allocate_char(stacktop,'\t');
}
return NULL; /* dummy return */
}
LispObject read_character(LispObject *stacktop)
{
int k = nextchar();
switch (k) {
case 's': case 'S':
return read_long_name(stacktop, k, "space");
case 'n': case 'N':
return read_long_name(stacktop, k, "newline");
case 'r': case 'R':
return read_long_name(stacktop, k, "return");
case 't': case 'T':
return read_long_name(stacktop, k, "tab");
}
return allocate_char(stacktop, k);
}
LispObject readatom(LispObject *stacktop)
{
int k=nextchar(); /* FIRST CHARACTER OF ATOM, MAYBE */
boffop = 0;
/* decide what sort of atom it might be... */
top:
switch (k) {
case '"':
return readstring(stacktop);
case '\\':
k = nextchar();
if (k==0xff)
(void) CallError(NULL, "\\ followed by end of file is illegal",
nil,NONCONTINUABLE);
case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
case 'g': case 'h': case 'i': case 'j': case 'k': case 'l':
case 'm': case 'n': case 'o': case 'p': case 'q': case 'r':
case 's': case 't': case 'u': case 'v': case 'w': case 'x':
case 'y': case 'z':
case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
case 'G': case 'H': case 'I': case 'J': case 'K': case 'L':
case 'M': case 'N': case 'O': case 'P': case 'Q': case 'R':
case 'S': case 'T': case 'U': case 'V': case 'W': case 'X':
case 'Y': case 'Z':
case '_': case '=': case '*': case '<': case '>': case '/':
return readidentifier(stacktop,k);
case '-': case '+':
packchar(k); /* PROBABLY A USEFUL THING TO DO */
k = nextchar();
if (isdigit(k)) goto numeric;
pushchar(stacktop,k);
--boffop; /* HACK !! */
return readidentifier(stacktop,boffo[0]);
case '(': case ')': case '.': case '\'': case '`': case ',':
ttype = 3;
return ascii(stacktop,k);
case ';':
while (getc((current_input->STREAM).handle) != '\n');
return readatom(stacktop);
case EOF:
case 0xff:
ttype = 3;
return q_eof;
case '#':
k = nextchar();
switch (k) {
case '\\': /* a character */
return read_character(stacktop);
default:
(void)CallError(stacktop,
"unknown escape character",allocate_char(stacktop,k),
NONCONTINUABLE);
}
numeric:
case '0': case '1': case '2': case '3': case '4':
case '5': case '6': case '7': case '8': case '9':
return readnumber(stacktop,k);
case ' ': case '\t': case '\n':
k = nextchar();
goto top; /* restart readatom */
default:
(void) CallError(stacktop, "classification type in readatom ~d",
allocate_integer(stacktop,k),NONCONTINUABLE);
}
return nil;
}
LispObject readidentifier(LispObject *stacktop, int k)
{
ttype = 0;
while (TRUE) {
packchar(k);
k = nextchar(); /* look at next character */
if (k=='\\') {
k = nextchar();
if (k==0xff)
CallError(NULL,
"\\ followed by end of file is illegal",nil,NONCONTINUABLE);
} /* classify as a letter */
else if (!isalnum(k) &&
k!='_' && k!='-' && k!='>' && k!='<' &&
k!='=' && k!='/' && k!='*')
break;
}
packchar('\0'); /* C string terminator */
pushchar(stacktop,k); /* the terminator character has not been read, logically */
return lookupname(stacktop,boffop);
}
LispObject readstring(LispObject *stacktop)
{
/* I just read a " mark, so now I want to read in a string */
int k=0;
ttype = 1;
top:
k = nextchar();
if (k==0xff) (void) CallError(stacktop,
"end of file in a string",nil,NONCONTINUABLE);
if (k=='\\') {
k = nextchar();
switch (k) {
case 'n':
k = '\n';
break;
case 'r':
k = '\r';
break;
case 't':
k = '\t';
break;
case 'p':
k = '\f';
break;
default:
break;
}
}
else if (k=='"') /* probably end of string */
goto stringcomplete;
boffo[boffop++] = k;
if (boffop>250) (void) CallError(stacktop,
"string too long",nil,NONCONTINUABLE);
goto top;
stringcomplete:
packchar('\0');
return allocate_string(stacktop, boffo,boffop);
}
LispObject readinteger(LispObject *stacktop, int k)
{
/* k is the first character of the number, and is a + or - or a digit */
ttype = 2;
while (TRUE) {
packchar(k);
k = nextchar();
if (!isdigit(k)) break;
}
/* here at end of integer */
pushchar(stacktop,k);
packchar('\0');
return numob(stacktop,boffop-1);
}
LispObject readnumber(LispObject *stacktop, int k)
{
int pointflag = FALSE;
char lastk = k;
/* k as above... */
ttype = 2;
while (TRUE) {
packchar(k);
k = nextchar();
if (!isdigit(k) && !(k == '.' && !pointflag)) break;
if (k == '.') pointflag = TRUE;
lastk = k;
}
/* End of number */
if (lastk == '.') {
pushchar(stacktop,lastk);
--boffop;
pointflag = FALSE;
}
pushchar(stacktop,k);
packchar('\0');
if (pointflag) return(floatob(stacktop,boffop-1));
return(numob(stacktop,boffop-1));
}
/* See following function as well */
EUFUN_1( Fn_read, stream)
{
extern LispObject Fn_Lex_Yacc_reader(LispObject*,FILE *);
LispObject k=nil;
if (stream==NULL || stream==nil)
current_input = StdIn;
else {
current_input = stream;
}
/*
while (TRUE) {
OFF_collect();
k = read0(stacktop);
ON_collect();
if (ttype == 3) {
if (k==q_eof) {
if (eofflag) (void) CallError("end of file",nil,NONCONTINUABLE);
eofflag = TRUE;
return q_eof;
}
else if (k == q_rpar) {
eofflag = FALSE;
continue;
}
}
eofflag = FALSE;
return k;
}
return(nil);
*/
if (current_input->STREAM.handle == NULL)
CallError(stacktop, "read: null stream",current_input,NONCONTINUABLE);
OFF_collect();
k=Fn_Lex_Yacc_reader(stacktop, current_input->STREAM.handle);
ON_collect();
if (current_input!=StdIn) yyin=stdin;
return k;
}
EUFUN_CLOSE
/* Same as Fn_read, except it has line number information */
EUFUN_1( Fn_read_ln, stream)
{
extern LispObject Fn_Lex_Yacc_reader_linenos(LispObject*,FILE *);
LispObject k=nil;
if (stream==NULL || stream==nil)
current_input = StdIn;
else {
current_input = stream;
}
if (current_input->STREAM.handle == NULL)
CallError(stacktop, "read: null stream",current_input,NONCONTINUABLE);
OFF_collect();
k=Fn_Lex_Yacc_reader_linenos(stacktop, current_input->STREAM.handle);
ON_collect();
if (current_input!=StdIn) yyin=stdin;
return k;
}
EUFUN_CLOSE
LispObject ascii(LispObject *stacktop,int n)
{
boffo[0]=n;
if (boffo[0]=='(') return q_lpar;
if (boffo[0]==')') return q_rpar;
if (boffo[0]=='.') return q_period;
if (boffo[0]=='\'') return q_quotemark;
if (boffo[0]=='`') return q_backquotemark;
if (boffo[0]==',') return q_comma;
return lookupname(stacktop,1);
}
LispObject floatob(LispObject *stacktop, int len)
{
double f;
IGNORE(len);
if (boffo[0] == '-') {
if (sscanf(boffo,"-%lf",&f) != 1)
return(get_symbol(stacktop,"-"));
else
return(allocate_float(stacktop, -f));
}
if (boffo[0] == '+') {
if (sscanf(boffo,"+%lf",&f) != 1)
return(get_symbol(stacktop,"+"));
else
return(allocate_float(stacktop, f));
}
sscanf(boffo,"%lf",&f);
return(allocate_float(stacktop, f));
}
LispObject numob(LispObject *stacktop, int len)
{
/* temporary: small integer only */
if (boffo[0]=='-') {
if (sscanf(boffo,"-%d",&len) != 1)
return(get_symbol(stacktop,"-"));
else
return allocate_integer(stacktop, -len);
}
if (boffo[0]=='+') {
if (sscanf(boffo,"+%d",&len) != 1)
return(get_symbol(stacktop,"+"));
else
return allocate_integer(stacktop, len);
}
sscanf(boffo,"%d",&len);
return allocate_integer(stacktop, len);
}
LispObject lookupname(LispObject *stacktop, int len)
{
LispObject i;
IGNORE(len);
for(i = (ObList); i!=NULL; i = i->SYMBOL.left) {
if (strcmp(boffo,stringof(i->SYMBOL.pname))==0) {
return i;
}
}
{ /* char *malloc(); */
char *tmp = malloc(len);
strcpy(tmp,boffo);
return (LispObject)get_symbol(stacktop,tmp);
}
}
EUFUN_1( Fn_endofstreamcharp, obj)
{
return (is_char(obj) && (obj->CHAR).code==EOF ? lisptrue : nil);
}
EUFUN_CLOSE
EUFUN_1( Fn_endoflinecharp, obj)
{
return (is_char(obj) && (obj->CHAR).code=='\n' ? lisptrue : nil);
}
EUFUN_CLOSE
EUFUN_1( Fn_readchar, stream)
{
int k;
if (stream==NULL || stream==nil) current_input = StdIn;
else current_input = stream;
yyin = (current_input->STREAM).handle;
#ifdef WITH_FUDGE
{
extern void yy_reset_stream(FILE *);
yy_reset_stream(current_input->STREAM.handle);
}
#endif
k = getc((current_input->STREAM).handle);
return (LispObject) (( k == EOF) ? q_eof : allocate_char(stacktop, (char)k));
}
EUFUN_CLOSE
EUFUN_1( Fn_readbyte, stream)
{
int k;
/*++IGNORE(env);*/
if (stream==NULL || stream==nil) current_input = StdIn;
else current_input = stream;
#ifdef WITH_FUDGE
{
extern void yy_reset_stream(FILE *);
yy_reset_stream(current_input->STREAM.handle);
}
#endif
k = getc((current_input->STREAM).handle);
return (LispObject) allocate_integer(stacktop, k);
}
EUFUN_CLOSE
EUFUN_1( Fn_peekchar, stream)
{
char k;
if (stream==NULL || stream==nil) current_input = StdIn;
else current_input = stream;
#ifdef WITH_FUDGE
{
extern void yy_reset_stream(FILE *);
yy_reset_stream(current_input->STREAM.handle);
}
#endif
k = getc((current_input->STREAM).handle);
ungetc(k,(current_input->STREAM).handle);
return (LispObject) allocate_char(stacktop,k);
}
EUFUN_CLOSE
EUFUN_1( Fn_peekbyte, stream)
{
char k;
/*++IGNORE(env);*/
if (stream==NULL || stream==nil) current_input = StdIn;
else current_input = stream;
#ifdef WITH_FUDGE
{
extern void yy_reset_stream(FILE *);
yy_reset_stream(current_input->STREAM.handle);
}
#endif
k = getc((current_input->STREAM).handle);
ungetc(k,(current_input->STREAM).handle);
return (LispObject) allocate_integer(stacktop, k);
}
EUFUN_CLOSE